home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / perl5 / perl5.002 / ext / dynaloader / dl_os2.xs < prev    next >
Encoding:
Text File  |  1996-01-20  |  3.8 KB  |  188 lines
  1. /* dl_os2.xs
  2.  * 
  3.  * Platform:    OS/2.
  4.  * Author:    Andreas Kaiser (ak@ananke.s.bawue.de)
  5.  * Created:    08th December 1994
  6.  */
  7.  
  8. #include "EXTERN.h"
  9. #include "perl.h"
  10. #include "XSUB.h"
  11.  
  12. #define INCL_BASE
  13. #include <os2.h>
  14.  
  15. #include "dlutils.c"    /* SaveError() etc    */
  16.  
  17. static ULONG retcode;
  18.  
  19. static void *
  20. dlopen(char *path, int mode)
  21. {
  22.     HMODULE handle;
  23.     char tmp[260], *beg, *dot;
  24.     char fail[300];
  25.     ULONG rc;
  26.  
  27.     if ((rc = DosLoadModule(fail, sizeof fail, path, &handle)) == 0)
  28.         return (void *)handle;
  29.  
  30.     /* Not found. Check for non-FAT name and try truncated name. */
  31.     /* Don't know if this helps though... */
  32.     for (beg = dot = path + strlen(path);
  33.          beg > path && !strchr(":/\\", *(beg-1));
  34.          beg--)
  35.         if (*beg == '.')
  36.             dot = beg;
  37.     if (dot - beg > 8) {
  38.         int n = beg+8-path;
  39.         memmove(tmp, path, n);
  40.         memmove(tmp+n, dot, strlen(dot)+1);
  41.         if (DosLoadModule(fail, sizeof fail, tmp, &handle) == 0)
  42.             return (void *)handle;
  43.     }
  44.  
  45.     retcode = rc;
  46.     return NULL;
  47. }
  48.  
  49. static void *
  50. dlsym(void *handle, char *symbol)
  51. {
  52.     ULONG rc, type;
  53.     PFN addr;
  54.  
  55.     rc = DosQueryProcAddr((HMODULE)handle, 0, symbol, &addr);
  56.     if (rc == 0) {
  57.         rc = DosQueryProcType((HMODULE)handle, 0, symbol, &type);
  58.         if (rc == 0 && type == PT_32BIT)
  59.             return (void *)addr;
  60.         rc = ERROR_CALL_NOT_IMPLEMENTED;
  61.     }
  62.     retcode = rc;
  63.     return NULL;
  64. }
  65.  
  66. static char *
  67. dlerror(void)
  68. {
  69.     static char buf[300];
  70.     ULONG len;
  71.  
  72.     if (retcode == 0)
  73.         return NULL;
  74.     if (DosGetMessage(NULL, 0, buf, sizeof buf - 1, retcode, "OSO001.MSG", &len))
  75.         sprintf(buf, "OS/2 system error code %d", retcode);
  76.     else
  77.         buf[len] = '\0';
  78.     retcode = 0;
  79.     return buf;
  80. }
  81.  
  82.  
  83. static void
  84. dl_private_init()
  85. {
  86.     (void)dl_generic_private_init();
  87. }
  88.  
  89. static char *
  90. mod2fname(sv)
  91.      SV   *sv;
  92. {
  93.     static char fname[9];
  94.     int pos = 7;
  95.     int len;
  96.     AV  *av;
  97.     SV  *svp;
  98.     char *s;
  99.  
  100.     if (!SvROK(sv)) croak("Not a reference given to mod2fname");
  101.     sv = SvRV(sv);
  102.     if (SvTYPE(sv) != SVt_PVAV) 
  103.       croak("Not array reference given to mod2fname");
  104.     if (av_len((AV*)sv) < 0) 
  105.       croak("Empty array reference given to mod2fname");
  106.     s = SvPV(*av_fetch((AV*)sv, av_len((AV*)sv), FALSE), na);
  107.     strncpy(fname, s, 8);
  108.     if ((len=strlen(s)) < 7) pos = len;
  109.     fname[pos] = '_';
  110.     fname[pos + 1] = '\0';
  111.     return (char *)fname;
  112. }
  113.  
  114. MODULE = DynaLoader    PACKAGE = DynaLoader
  115.  
  116. BOOT:
  117.     (void)dl_private_init();
  118.  
  119.  
  120. void *
  121. dl_load_file(filename)
  122.     char *        filename
  123.     CODE:
  124.     int mode = 1;     /* Solaris 1 */
  125. #ifdef RTLD_LAZY
  126.     mode = RTLD_LAZY; /* Solaris 2 */
  127. #endif
  128.     DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
  129.     RETVAL = dlopen(filename, mode) ;
  130.     DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
  131.     ST(0) = sv_newmortal() ;
  132.     if (RETVAL == NULL)
  133.     SaveError("%s",dlerror()) ;
  134.     else
  135.     sv_setiv( ST(0), (IV)RETVAL);
  136.  
  137.  
  138. void *
  139. dl_find_symbol(libhandle, symbolname)
  140.     void *    libhandle
  141.     char *    symbolname
  142.     CODE:
  143. #ifdef DLSYM_NEEDS_UNDERSCORE
  144.     char symbolname_buf[1024];
  145.     symbolname = dl_add_underscore(symbolname, symbolname_buf);
  146. #endif
  147.     DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
  148.     libhandle, symbolname));
  149.     RETVAL = dlsym(libhandle, symbolname);
  150.     DLDEBUG(2,fprintf(stderr,"  symbolref = %x\n", RETVAL));
  151.     ST(0) = sv_newmortal() ;
  152.     if (RETVAL == NULL)
  153.     SaveError("%s",dlerror()) ;
  154.     else
  155.     sv_setiv( ST(0), (IV)RETVAL);
  156.  
  157.  
  158. void
  159. dl_undef_symbols()
  160.     PPCODE:
  161.  
  162. char *
  163. mod2fname(sv)
  164.      SV   *sv;
  165.  
  166.  
  167. # These functions should not need changing on any platform:
  168.  
  169. void
  170. dl_install_xsub(perl_name, symref, filename="$Package")
  171.     char *        perl_name
  172.     void *        symref 
  173.     char *        filename
  174.     CODE:
  175.     DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
  176.         perl_name, symref));
  177.     ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
  178.  
  179.  
  180. char *
  181. dl_error()
  182.     CODE:
  183.     RETVAL = LastError ;
  184.     OUTPUT:
  185.     RETVAL
  186.  
  187. # end.
  188.